home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / self / contrib.lha / contrib / SelfNews / synthetics.self < prev    next >
Text File  |  1993-07-24  |  4KB  |  181 lines
  1.  "File synthetics.self
  2.  created by Ian Wilkinson on Mon Sep 21 17:36:45 1992
  3.  
  4.  Copyright (c) Canon Research Centre Europe, 1992.
  5.  All rights reserved."
  6.  
  7. oddballs userInterface _AddSlotsIfAbsent: ( | ^ syntheticsWarehouse = () | ) 
  8. syntheticsWarehouse _Define: ( | 
  9.     _ parent* = traits oddball.
  10.  
  11.     ^ participant = ( |
  12.     ^ behaviour = 2.
  13.     ^ looks = (
  14.         '/ClassParticipant [ ClassCanvas ClassGeneric ]
  15.         dictbegin
  16.         /name            nullstring    def
  17.         /nameSeenBySystem    nullstring    def
  18.         /homeAddress        nullstring    def
  19.         /loginShell        nullstring    def
  20.         /pic            null        def
  21.         dictend
  22.         classbegin
  23.         /FillingInX        20    def
  24.         /FillingInY        20    def
  25.         /ParticipantHeight    25    def
  26.         /PicW            64    def
  27.         /PicH            64    def
  28.         /NameFont /Helvetica findfont 14 scalefont    def
  29.         /NameFontH        NameFont fontheight    def
  30.  
  31.         /NewInit { % tk tgStart creationArgs => -
  32.             /NewInit super send
  33.             [
  34.             /tk /tgStart 
  35.             /name /nameSeenBySystem /homeAddress /loginShell /pic
  36.             ]
  37.             [] methoddict
  38.             begin
  39.             2 dict dup begin
  40.                 /QuitApp tgStart def
  41.                 /NewObserver tgStart 1 add def
  42.             end tk /setwireclient self send
  43.             NameFont /settextfont self send
  44.             /installStdBehaviour self send
  45.             end
  46.         } def
  47.  
  48.         /installStdBehaviour { % - => -
  49.             [] [ /theMenu ] methoddict
  50.             begin   
  51.             /installStdBehaviour super send
  52.             /theMenu /Grid framebuffer /new ClassMenu send store
  53.             [   
  54.                 [ (Quit)    /removeFromWorld ]
  55.                 [ (Observe)    /newObserver ]
  56.             ] /setitemlist theMenu send
  57.             self /settarget theMenu send
  58.             theMenu /setmenu self send
  59.             end
  60.         } def 
  61.  
  62.         /newObserver { % cntl => -
  63.             [] /NewObserver self messageSelf
  64.         } def
  65.  
  66.         /participantIsNamed { % name => -
  67.             /name exch store
  68.             gsave
  69.             self setcanvas
  70.             /textfont self send setfont
  71.             /minsize [
  72.                 /bbox self send pop pop
  73.                 name stringwidth pop FillingInX add ParticipantHeight
  74.             ] cvx /promote self send
  75.             grestore
  76.         } def
  77.  
  78.         /Paint { % - => -
  79.             [] [ /x /y /w /h ] methoddict
  80.             begin
  81.             /bbox self send [ /x /y /w /h ] methodstacktodict
  82.             x y w h false /Paint3DBox self send
  83.             gsave
  84.                 ColorDict /Blue get setcolor
  85.                 /textfont self send setfont
  86.                 pic null eq {
  87.                 w 2 div h 2 div moveto
  88.                 name /CenterShow self send
  89.                 }{
  90.                 w 2 div h NameFontH sub 5 sub moveto
  91.                 name /CenterShow self send
  92.                 gsave
  93.                     w 2 div PicW 2 div sub 
  94.                     h NameFontH sub PicH sub 10 sub translate
  95.                     0 0 moveto
  96.                     PicW PicH scale
  97.                     pic imagecanvas
  98.                 grestore
  99.                 } ifelse
  100.             grestore
  101.             end
  102.         } def
  103.  
  104.         /minsize { % - => width height
  105.             gsave
  106.             self setcanvas
  107.             /textfont self send setfont
  108.             name stringwidth pop FillingInX add
  109.             pic null eq {
  110.                 ParticipantHeight
  111.             }{
  112.                 PicW FillingInX add max
  113.                 PicH NameFontH add FillingInY add
  114.             } ifelse
  115.             grestore
  116.         } def
  117.         classend def
  118.         '
  119.     ).
  120.  
  121.     ^ instantiate = (
  122.         'framebuffer /new ClassParticipant send
  123.         /place 1 index send
  124.         /new ClassEventMgr send /activate 2 index send
  125.         /map exch send
  126.         '
  127.     ).
  128.  
  129.     ^ instantiateWithoutInteraction = (
  130.         'framebuffer /new ClassParticipant send
  131.         /place exch send
  132.         '
  133.     ).
  134.  
  135.     ^ customLooks* = ( |
  136.         ^ removeFromWorld = ('
  137.         /removeFromWorld {
  138.             self /removeclient Parent send { pop } if
  139.             /paint Parent send
  140.             %[] /QuitApp self send
  141.             %/destroy self send
  142.         } /promote
  143.         '
  144.         ).
  145.  
  146.         ^ trackMotion = ('
  147.         /TrackMotion { % evt => -
  148.             /Coordinates get aload pop offsetX offsetY xysub
  149.             /move self send
  150.             self /client Parent send {
  151.             gsave
  152.                 Parent setcanvas
  153.                 [ /location self send ]
  154.                 /SetLayoutData Parent send
  155.             grestore
  156.             } if
  157.         } /promote
  158.         '
  159.         )
  160.     | ).
  161.  
  162.     ^ named = (
  163.         ' /participantIsNamed '.
  164.     )
  165.     | ).
  166.  
  167.     ^ engenderLooks = ( | mirr |
  168.     mirr: reflect: self.
  169.     mirr do: [ | :aSlot. mirrOnRep |
  170.         (aSlot isMethod || aSlot isParent) not
  171.         ifTrue: [
  172.             mirrOnRep: reflect: aSlot key sendTo: self.
  173.             (mirrOnRep includesName: 'looks')
  174.             ifTrue: [ 
  175.                 postScriptMachine sendPS: (aSlot key sendTo: self) looks
  176.             ]
  177.         ]
  178.     ]
  179.     )
  180. | ) 
  181.